home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD ROM Paradise Collection 4
/
CD ROM Paradise Collection 4 1995 Nov.iso
/
bbs
/
jdrexa10.zip
/
INST4OF4.DAT
/
BBS
/
GIP_02.ZIP
/
VIEWGIP.BAS
< prev
next >
Wrap
BASIC Source File
|
1994-12-18
|
21KB
|
788 lines
'
' ViewGIP r.02
' John David Rohner, Milwaukee, WI
' December 1994
'
' Copyright (c) 1994, John Rohner. All rights reserved.
'
'Release History
'
' .01 Iniital release.
' .02 Now handles wildcards, and .ICO for the input filename. Providing the
' useful: VIEWGIP *.ICO or VIEWGIP *.GIP, etc.
' Dropped the CGA use-top-4-colors adjusting code for .ICO viewing.
' Added whatever BMP code I could come up with.
' 286 or better now required.
'
DEFINT A-Z
'
' Some constants and data types (from JDR_BBS).
'
TYPE FileInfo 'Len = 29
FName AS STRING * 12 'File name.
FSize AS LONG 'File Size in bytes.
FDate AS STRING * 9 'File date (sometimes).
END TYPE
'
' General subroutine library (from JDR_BBS).
'
DECLARE SUB Ansi (Inpt$)
DECLARE FUNCTION AscMid% (Inpt$, BYVAL Start%)
DECLARE FUNCTION BitsRol% (BYVAL Inpt%, BYVAL ShiftLeft%)
DECLARE FUNCTION BitsRor% (BYVAL Inpt%, BYVAL ShiftRight%)
DECLARE FUNCTION BitsShr% (BYVAL Inpt%, BYVAL ShiftRight%)
DECLARE FUNCTION BitsShl% (BYVAL Inpt%, BYVAL ShiftRight%)
DECLARE SUB BitSet (Inpt%, BYVAL BitNum%)
DECLARE SUB ColorText (BYVAL Horiz%, BYVAL Vert%, BYVAL attr%, BYVAL char%)
DECLARE SUB CursorOff ()
DECLARE SUB CursorOn ()
DECLARE SUB Delay ()
DECLARE FUNCTION FindF% (File$, Typ AS FileInfo)
DECLARE SUB FileClose (BYVAL Handle%)
DECLARE SUB FileGetSLoc (BYVAL Handle%, BYVAL Location&, Inpt$)
DECLARE FUNCTION FileOpen% (FileName$,BYVAL attr%)
DECLARE SUB GLine (BYVAL CurrentH%, BYVAL CurrentV%, BYVAL TillH%, BYVAL TillV%, BYVAL Colr%, BYVAL GDither%)
DECLARE SUB GPixel (BYVAL Horiz%, BYVAL Vert%, BYVAL Colr%)
DECLARE SUB GPixel2 ()
DECLARE SUB GSetMode (BYVAL GMode%, BYVAL VGA1%, BYVAL VGA2%)
DECLARE FUNCTION KBIn% ()
DECLARE FUNCTION LongMid& (Inpt$, BYVAL Start%)
DECLARE FUNCTION IntMid% (Inpt$, BYVAL Start%)
DECLARE FUNCTION StrSrch1% (Inpt$, BYVAL Find%)
DECLARE FUNCTION StrSrch2% (BYVAL Start%, Inpt$, BYVAL Find%)
DECLARE FUNCTION StrSrchR% (Inpt$, BYVAL Ascii%)
declare sub delaytiny (byval i%)
declare sub getpalette (a$)
declare sub setpalette (a$)
declare sub DAMCSHLF (byval i0%, byval i1%, a$, byval i3%, byval i4%)
DECLARE SUB FilePutSEnd (BYVAL Handle%, Inpt$)
'
' Program specific subroutine library.
'
DECLARE SUB DoGIPForBBS (p$,p)
DECLARE SUB FileCloseR (p)
DECLARE FUNCTION FileOpenR% (p$)
DECLARE SUB GBox (p,p0,p1,p2,p3,p4)
DECLARE SUB GBoxFilled (p,p0,p1,p2,p3,p4)
DECLARE SUB GIPParse1 (p$,p0$,p)
DECLARE SUB GIPParse2 (p$,p0,p1,p2)
DECLARE FUNCTION ParseForPath$ (p$)
DECLARE SUB ShowIcon2 (p$)
DECLARE SUB ShowBMP (p$)
DECLARE FUNCTION Val4& (p$)
'
' Global variables.
'
COMMON SHARED _
C1310$, Null$, Chars$(), FFile AS FileInfo, Buff$, _
GInUse, GHoriz, GVert, GColor, GPattern, GPatShift, GObjects$()
'
' Actual program start.
'
REDIM Chars$(255)
FOR K = 0 TO 255
Chars$(K) = CHR$(K)
NEXT
C1310$ = Chars$(13) + Chars$(10)
CALL Ansi("ViewGIP GIP-able file lister release .02" + C1310$)
CALL Ansi("Copyright (C) John David Rohner 1993. All rights reserved." + C1310$ + C1310$)
Null$ = ""
REDIM GObjects$(255)
K$ = UCASE$(RTRIM$(LTRIM$(Command$)))
K = FindF(K$,FFile)
IF K = 0 THEN K$ = K$ + ".GIP" : _
K = FindF(K$,FFile)
IF K = 0 _
THEN CALL Ansi("1File not found. Use ViewGIP <pathname>" + C1310$) : _
CALL Ansi("1Wildcards OK." + C1310$ + C1310$) : _
END
K3$ = K$
K3 = 0
K$ = ParseForPath$(K$)
DO
K3 = K3 + 1
GInUse = 0
GHoriz = 1
GVert = 1
GColor = 1
GPattern = -1
GPatShift = 0
SELECT CASE RIGHT$(RTRIM$(FFile.FName),4)
CASE ".ICO" : CALL GSetMode(2,0,0)
CALL ShowIcon2(K$ + FFile.FName)
CASE ".BMP" : CALL GSetMode(2,0,0)
CALL ShowBMP(K$ + FFile.FName)
CASE ELSE
Buff$ = SPACE$(FFile.FSize)
K = FileOpenR(K$ + FFile.FName)
CALL FileGetSLoc(K,0&,Buff$)
CALL FileCloseR(K)
CALL DoOutput
END SELECT
DO : K = KBIn
LOOP UNTIL K > 0
SELECT CASE K
CASE IS > 18000
K = -2
DO
IF K < 0 _
THEN K0 = GHoriz : _
K1 = GVert : _
Buff$ = "C14;G104,176,0;H =" + STR$(GHoriz) + "G176,176,0;V =" + STR$(GVert) : _
Buff$ = "P0,0;C0;G135,175,0;F24,8,0;G207,175,0;F24,8,0;" + Buff$ : _
CALL DoOutput : _
GHoriz = K0 : _
GVert = K1 : _
CALL GPixel(GHoriz,GVert,14)
K = KBIn
SELECT CASE K
CASE 18432 : GVert = GVert - 1
K = -1
CASE 20480 : GVert = GVert + 1
K = -1
CASE 19200 : GHoriz = GHoriz - 1
K = -1
CASE 19712 : GHoriz = GHoriz + 1
K = -1
CASE 20736 : GVert = GVert + 1
GHoriz = GHoriz + 1
K = -1
CASE 18688 : GVert = GVert - 1
GHoriz = GHoriz + 1
K = -1
CASE 18176 : GVert = GVert - 1
GHoriz = GHoriz - 1
K = -1
CASE 20224 : GVert = GVert + 1
GHoriz = GHoriz - 1
K = -1
END SELECT
LOOP UNTIL K > 0
END SELECT
CALL GSetMode(0,0,0)
CALL CursorOn
K4 = 0
K = FindF(K3$,FFile)
DO
K5 = FindF(Null$,FFile)
K4 = K4 + 1
LOOP UNTIL K4 = K3
LOOP UNTIL K5 = 0
END
SUB DoOutput
WHILE LEN(Buff$) > 0
K = ASC(Buff$)
SELECT CASE K
CASE 19
K = 1
CALL DoGIPForBBS(Buff$,K)
Buff$ = MID$(Buff$,K)
CASE ELSE
SELECT CASE GInUse
CASE 0
SELECT CASE K
CASE 27
K$ = Null$
DO
K0 = ASC(Buff$)
K$ = K$ + Chars$(K0)
Buff$ = MID$(Buff$,2)
LOOP UNTIL StrSrch1("fmCsuJKHABDR",K0) > 0 OR LEN(Buff$) = 0
CALL Ansi(K$)
CASE ELSE
CALL Ansi(Chars$(K))
Buff$ = MID$(Buff$,2)
END SELECT
CASE ELSE
IF K = 13 THEN GHoriz = 0 : _
GVert = GVert + 8 : _
K = -1
IF K = 10 THEN K = -1
IF K >= 0 THEN CALL ColorText(GHoriz,GVert,GColor,K) : _
GHoriz = GHoriz + 8
Buff$ = MID$(Buff$,2)
END SELECT
END SELECT
WEND
END SUB
'
' General program routines.
'
'* * * * * *
' This routine will open a file in read-only, and read/write
' share mode.
'
' p$ pathname of the file to open.
'
' Date last checked for perfection: Oct 21 1993
'
FUNCTION FileOpenR% (p$)
K = FileOpen(p$,128)
IF K = -1 THEN TT$ = C1310$ + C1310$ + _
"
File error, unable to open " + _
p$ + "" + C1310$ + C1310$ : _
CALL Ansi(TT$) : _
SYSTEM
FileOpenR% = K
END FUNCTION
'
'* * * *
'* * * * * *
' This routine will close a file opened with FileOpenR.
'
' p handle of already-opened file.
'
' Date last checked for perfection: Oct 21 1993
'
SUB FileCloseR (p)
CALL FileClose(p)
END SUB
'
'* * * *
'* * * * * *
' This routine will convert a string to a number.
'
' p$ is the number in string form to use.
'
' This routine returns the value as seen from the opposite
' end, and stops when it reaches the first backwards
' non-number. Under VAL() '123xyz' = 123, here it = 0. Under
' VAL() 'xyz123' = 0, here it equals 123.
'
' Found no use for negatives. So, the negative symbol will be
' just another 'nonnumeric stop flag'.
'
' Trailing spaces are ignored.
'
' Leading spaces and zero's are ignored. Although ' xx yy'
' will still only return yy, as the space between two numbers
' is a stopper.
'
' It only works with integers, thus sending '101.50' will
' return 50.
'
' For numbers greater than 1,xxx,xxx,xxx we stop at the "1"
' position.
'
' Date last checked for perfection: Oct 15 1993
'
FUNCTION Val4& (p$)
k& = 0
k0& = 1
K = LEN(RTRIM$(p$))
SELECT CASE K
CASE IS > 15
K3 = 0
FOR K0 = 0 TO 15
K1 = AscMid(p$,K - K0) - 48
IF K1 = 1 THEN CALL BitSet(K3,K0 + 1) _
ELSE IF K1 <> 0 THEN EXIT FOR
NEXT
IF K0 = 16 THEN K = -1 : _
K& = K3
END SELECT
K1 = 0
SELECT CASE K
CASE IS > 0
DO
K0 = AscMid(p$,K) - 48
K1 = K1 + 1
IF (K0 < 0) OR (K0 > 9) OR (K1 = 11) OR (K1 = 10 AND K0 > 1) _
THEN EXIT DO
k& = k& + k0& * K0
k0& = 10 * k0&
K = K - 1
LOOP UNTIL K = 0
IF K > 0 THEN IF AscMid(p$,K) = 45 THEN K& = - K&
END SELECT
Val4& = k&
END FUNCTION
'
'* * * *
'
' GIP routines.
'
'* * * * * *
' This routine will process a GIP string.
'
' p$ string containing GIP code (can be the full string, not just
' the short GIP-only segment).
'
' p offset in p$ working on now, p is updated upon exit.
'
' Date last checked for perfection: Dec 7 1993
'
SUB DoGIPForBBS (p$,p)
K = p
CALL GIPParse1(p$,K$,p)
K1 = GHoriz
K2 = GVert
K = AscMid(p$,K + 1)
IF GInUse < 0 THEN K = 0
IF LEN(K$) = 0 THEN K = 0
SELECT CASE K
CASE 83
'
' Sn; switch to screen mode n.
'
GHoriz = 0
GVert = 0
GColor = 15
GPattern = -1
GPatShift = 0
GInUse = 0
K = Val4&(K$)
IF K < 256 THEN GInUse = K
CALL GSetMode(GInUse,0,0)
CALL CursorOff
CASE 67
'
' Cn; switch to color n.
'
K = Val4&(K$)
IF K < 256 THEN GColor = K
CASE 71
'
' Gh,v,d; go to to screen point h,v,d.
'
CALL GipParse2(K$,GHoriz,GVert,0)
CASE 77
'
' Mh,v,d; go to to offset point h,v,d.
'
CALL GipParse2(K$,GHoriz,GVert,0)
GHoriz = K1 + GHoriz
GVert = K2 + GVert
CASE 76
'
' Lh,v,d; draw a line to offset h,v,d.
'
CALL GipParse2(K$,GHoriz,GVert,0)
GHoriz = K1 + GHoriz
GVert = K2 + GVert
IF GInUse > 0 THEN CALL GLine(K1,K2,GHoriz,GVert,GColor,GPattern)
CASE 66
'
' Bh,v,d; draw a rectangle to offset corner h,v,d.
'
CALL GipParse2(K$,K1,K2,0)
IF GInUse > 0 _
THEN CALL GBox(GHoriz,GVert,GHoriz + K1,GVert + K2,GColor,GPattern)
CASE 70
'
' Fh,v,d; draw a filled/solid rectangle to offset corner h,v,d.
'
CALL GipParse2(K$,K1,K2,0)
IF GInUse > 0 _
THEN CALL GBoxFilled(GHoriz,GVert,GHoriz + K1,GVert + K2,GColor,GPattern)
CASE 102
'
' fpathname; send a file.
'
K$ = UCASE$(K$)
SELECT CASE FindF(K$,FFile)
CASE IS <> 0
SELECT CASE RIGHT$(K$,4)
CASE ".ICO" : CALL ShowIcon2(K$)
CASE ".BMP" : CALL ShowBMP(K$)
CASE ELSE
CALL GSetMode(0,0,0)
K = FileOpenR(K$)
TT$ = " "
FOR K& = 0 TO FFile.FSize
CALL FileGetSLoc(K,K&,TT$)
CALL Ansi(TT$)
NEXT
CALL FileCloseR(K)
END SELECT
END SELECT
CASE 80
'
' Pn; switch to pattern n.
'
CALL GipParse2(K$,GPattern,0,GPatShift)
IF GPattern = 0 THEN GPattern = -1
CASE 79
'
' On;~xxx~ define Object number n.
'
K = Val4&(K$)
SELECT CASE K
CASE 1 TO 255
GObjects$(K) = Null$
SELECT CASE AscMid(p$,p)
CASE 126
p = p + 1
K0 = AscMid(p$,p)
WHILE K0 <> 126
GObjects$(K) = GObjects$(K) + Chars$(K0)
p = p + 1
K0 = AscMid(p$,p)
WEND
p = p + 1
END SELECT
END SELECT
CASE 111
'
' On; display Object number n.
'
K = Val4&(K$)
SELECT CASE K
CASE 1 TO 255
p$ = LEFT$(p$,p - 1) + GObjects$(K) + MID$(p$,p)
END SELECT
END SELECT
END SUB
'
'* * * *
'* * * * * *
' This routine will parse a section of string, pulling out the
' GIP string.
'
' p$ string to process.
'
' p0$ GIP string (excluding leading ASCII 19 and trailing ";").
'
' p upon entry it points to the ASCII 19, upon return it points
' to the semi-colon.
'
' Date last checked for perfection: Dec 7 1993
'
SUB GIPParse1 (p$,p0$,p)
K = StrSrch2(p,p$,59)
IF K > 0 AND LEN(p$) > 2 THEN p0$ = MID$(p$,p + 2,K - p - 2) _
ELSE p0$ = Null$
p = K + 1
END SUB
'
'* * * *
'* * * * * *
' This routine will parses a 3-D GIP string for its three
' coordinates.
'
' p$ string to process.
'
' p0 returns with the "h" (first) coordinate.
'
' p1 returns with the "v" (second) coordinate.
'
' p2 returns with the "d" (third) coordinate.
'
' Date last checked for perfection: Dec 7 1993
'
SUB GIPParse2 (p$,p0,p1,p2)
p0 = StrSrch1(p$,44)
p1 = StrSrch2(p0,p$,44)
IF p0 > 0 THEN p0 = Val4&(LEFT$(p$,p0 - 1))
IF p1 > 0 THEN p1 = Val4&(LEFT$(p$,p1 - 1))
p2 = Val4&(p$)
END SUB
'
'* * * *
'* * * * * *
' This routine will display an empty rectangle.
'
' p starting h coordinate.
'
' p0 starting v coordinate.
'
' p1 ending h coordinate.
'
' p2 ending v coordinate.
'
' p3 color to use.
'
' p4 pattern to use.
'
' Date last checked for perfection: Oct 22 1993
'
SUB GBox (p,p0,p1,p2,p3,p4)
CALL GLine(p,p0,p1,p0,p3,p4)
CALL GLine(p1,p0,p1,p2,p3,p4)
CALL GLine(p1,p2,p,p2,p3,p4)
CALL GLine(p,p2,p,p0,p3,p4)
END SUB
'
'* * * *
'* * * * * *
' This routine will display a filled rectangle.
'
' p starting h coordinate.
'
' p0 starting v coordinate.
'
' p1 ending h coordinate.
'
' p2 ending v coordinate.
'
' p3 color to use.
'
' p4 pattern to use (updated upon return).
'
' The pattern is rotated left after each line.
'
' Date last checked for perfection: Oct 22 1993
'
SUB GBoxFilled(p,p0,p1,p2,p3,p4)
SELECT CASE p0
CASE IS <= p2
FOR K = p0 TO p2
CALL GLine(p,K,p1,K,p3,p4)
IF GPatShift < 0 _
THEN p4 = BitsROL(p4,- GPatShift) _
ELSE IF GPatShift > 0 THEN p4 = BitsROR(p4,GPatShift)
NEXT
CASE ELSE
FOR K = p0 TO p2 STEP -1
CALL GLine(p,K,p1,K,p3,p4)
IF GPatShift < 0 _
THEN p4 = BitsROL(p4,- GPatShift) _
ELSE IF GPatShift > 0 THEN p4 = BitsROR(p4,GPatShift)
NEXT
END SELECT
END SUB
'
'* * * *
'* * * * * *
' This routine will display an icon.
'
' p$ pathname of file to use.
'
' It has a nice, and unecessary, processor to display the icons
' in CGA mode.
'
' Date last checked for perfection: Oct 22 1993
'
SUB ShowIcon2 (p$)
K$ = SPACE$(16)
K = FileOpenR(p$)
CALL FileGetSLoc(K,6,K$)
K0 = ASC(K$)
K1 = AscMid(K$,2)
K2 = AscMid(K$,3)
K3 = LongMid&(K$,9)
K& = LongMid&(K$,13)
K$ = SPACE$((K1 \ 2) * K0)
CALL FileGetSLoc(K,K& + 104,K$)
CALL FileCloseR(K)
CALL DAMCSHLF(GHoriz,GVert + K0,K$,K1 \ 2,4)
END SUB
'
'* * * *
'quick and dirty BMP viewer--trouble with the colors right now.
'
'also modify it to put the image at the current coordinates (and returing
'at those same coordiates).
SUB ShowBMP (p$)
CALL DoBMP(p$,aa$)
'x$ = space$(51)
x$ = space$(48)
call getpalette(x$)
'x$ = mid$(x$,4)
k = fileopen("pal.out",130)
call fileputsend(k,x$)
call fileclose(k)
y$ = x$
for a = 1 to len(aa$)
mid$(aa$,a,1) = CHR$(BitsShr(ASC(MID$(aa$,a,1)),2))
next
k = fileopen("pal2.out",130)
call fileputsend(k,aa$)
call fileclose(k)
call setpalette(aa$)
'x = -1
'do
' z$ = inkey$
' select case z$
' case "-"
' x = x - 1
' if x < 0 then x = 0
' for a = 1 to 48
' mid$(x$,a,1) = mid$(aa$,x + a,1)
' next
' call setpalette(x$)
' case "+"
' x = x + 1
' for a = 1 to 48
' mid$(x$,a,1) = mid$(aa$,x + a,1)
' next
' call setpalette(x$)
' CASE "1" : y$ = MID$(y$,2)
' x$ = y$
' call setpalette(x$)
' x = 0
' end select
'loop until z$ = "q" or z$ = "Q"
while inkey$ = "" : WEND
'x$ = space$(51)
x$ = space$(48)
call getpalette(x$)
'x$ = mid$(x$,4)
k = fileopen("pal.out",130)
call fileputsend(k,x$)
call fileclose(k)
call setpalette(y$)
END SUB
'
' to compile: BC VIEWGIP.BAS /O/S/FS/G2;
' to link : LINK /EXEPACK /PACKCODE VIEWGIP,,,ASSEMBLY\JDRBBS,,
' requires : BC.EXE, LINK.EXE, BCL70EFR.LIB, BRT70EFR.LIB, and JDRBBS.LIB
' (Basic PDS 7.0+, and Juggernaut's assembly library)
'
'* * * * * *
' Parse a pathname for the path.
'
' p$ pathname to work with.
'
' returns with the path (uppercased, with trailing '\').
'
' Date last checked for perfection: May 3 1993
'
FUNCTION ParseForPath$ (p$)
K = StrSrchR(p$,92)
IF K = 0 THEN K = StrSrchR(p$,47)
ParseForPath$ = UCASE$(LEFT$(p$,K))
END FUNCTION
'
'* * * *
SUB DoBMP (p$,aa$)
K = FileOpenR(p$)
zz$ = space$(27)
call filegetsloc(k,2&,zz$)
k1& = longmid(zz$,1) 'end of image
k& = longmid(zz$,9) 'start of image
kx1 = intmid(zz$,17) 'horizontal width
kx2 = intmid(zz$,21) 'vertical height
kz = ascmid(zz$,27) 'number of pixels per color
ab$ = space$(64) '16 * 3 \ 2
call filegetsloc(k,54&,ab$)
aa$ = Null$
for a = 1 to 16
aa$ = aa$ + MID$(ab$,(a - 1) * 4 + 1,3)
next
for a = 1 to 16 step 2
a$ = mid$(aa$,(a - 1) * 3 + 1,1)
b$ = mid$(aa$,(a - 1) * 3 + 3,1)
mid$(aa$,(a - 1) * 3 + 1,1) = b$
mid$(aa$,(a - 1) * 3 + 3,1) = a$
next
ghoriz = 0
aa = kx2
if kz = 8 then xx = kx1 _
else xx = kx1 \ 2
xy = (16384 \ xx) * xx
x$ = space$(xy)
do
if (k1& - k&) < xy then x$ = left$(x$,k1& - k&)
CALL FileGetSLoc(K,k&,x$)
'select case zz3
' case 1 : zz3 = 4
' case 2 : zz3 = 2
' case 3 : zz3 = 6
' case 4 : zz3 = 1
' case 5 : zz3 = 5
' case 6 : zz3 = 3
' case 7 : zz3 = 8
' case 8 : zz3 = 7
' case 9 : zz3 = 12
' case 10 : zz3 = 10
' case 11 : zz3 = 14
' case 12 : zz3 = 9
' case 13 : zz3 = 13
' case 14 : zz3 = 11
'end select
call DAMCSHLF(GHoriz,aa,x$,xx,kz)
k& = k& + xy
aa = aa - (xy \ xx)
loop until k& >= k1&
CALL FileCloseR(K)
END SUB